perm filename TR1.NEW[M11,LCS] blob
sn#373988 filedate 1979-01-05 generic text, type T, neo UTF8
C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
DIMENSION RX(100),JX(100),W(35),IINS(135)
C W(35) FOR PARAMETERS
COMMON /TR/I(80),IX(50),NN(2),LX(12),INST(27,5),MX5(40)
1,INSNUM(27),FQDR(5/32,27),P(30),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
INTEGER FQDR
DOUBLE PRECISION IX
EQUIVALENCE (IBL,LX(1)),(IZR,RZR)
1 ,(LESS,LX(9)),(RX,IX,IXJ,JX),(INN,RNN),(RX2,RX(3)),
1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
1,(IAROW,LX(7))
DATA IAMPR/'&'/,IAT/'@'/,IBLA/' '/
DATA LX/' ',';', '*','/','-','+'
1,"575004020100,'=','<' ,',' ,'(', ')'/, IFIRST/-1/,IOPEN/-1/
1 , IDOT/'.'/, IDEV/1/,JPRNT/-1/,JWRT/-1/,JFLNM/'FOR21'/
CC 1,ISCL/'CF','C','CS','DF','D','DS','EF','E','ES','FF','F','FS',
CC 1 'GF','G','GS','AF','A','AS','BF','B','BS'/,MX/0/
CCC 1, IDUR/'DUR'/,FILNM/"556563514300/,JPRNT/-1/,JWRT/-1/
C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: FOR21.DAT
DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./
1,IALT/"765004020100/
CC 1,IWD/'PLAY','FINI','SRATE','NCHNS','PRINT',
CC 1 'CHA','POWER','SRT','GEN'/
C LX INCLUDES ALL THE DIVIDERS.
555 LLLL=0
401 IF(IFIRST)404, 5,600
404 IGEN=-1
IF(INUM.NE.0)GO TO 30
DO 411 K=1,135
411 IINS(K)=0
C ZERO OUT INSTR. NAME ARRAY.
30 IPLAY=0
ENDX=0
JSEM=0
INS=-1
402 IDEV=1
TYPE 1
1 FORMAT(' INPUT? '$)
100 FORMAT(' >'$)
2 FORMAT(A4)
ACCEPT 2,IDBL
C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
IF(IDBL.NE.IBLA)GO TO 400
IDEV=5
GO TO 5
400 IF(IDBL.EQ.IAMPR)GO TO 603
C!*** & IS PRNT-NOPRNT FLIPFLOP
IF(IDBL.NE.IAT)GO TO 410
C!*** @ IS USED TO SET OUTPUT FILE NAME (DEFAULT=FOR21)
TYPE 399
399 FORMAT(' TYPE OUTPUT NAME -- ',$)
ACCEPT 2,JFLNM
GO TO 402
CCC IF(IDBL.EQ.'%')GO TO 604
C!*** % IS WRT-NOWRT FLIPFLOP
CXX REREAD 4,I
C! % WRITES BINARY FILE.
410 CALL IFILE(1,IDBL)
CXX CALL OFILE(22,'D')
CC410 OPEN(UNIT=1,FILE=NM)
4 FORMAT(80A1)
5 IF(JSEM.AND.J.LT.MM)GO TO 305
IF(JSEM.NE.99)GO TO 502
IFIRST=IFIRST+10
GO TO 555
CC RETURN
600 JSEM=0
IFIRST=IFIRST-10
INS=-1
502 IF(IDEV.NE.5)GO TO 601
IF(IGEN.NE.2)IGEN=-1
TYPE 100
601 READ(IDEV,4,END=404)I
CXCX IF(I(1).EQ.'!')GO TO 404
C!**** USE ! TO RETURN TO 'INPUT?'
IF(I(1).EQ.IBLA)GO TO 404
C!**** TYPE <CR> TO RETURN TO 'INPUT?'
CCC IF(I(1).EQ.'%')GO TO 604
C!*** %=WRITES BINARY FILE FOR21.DAT
IF(I(1).NE.IAMPR)GO TO 602
C!*** &=TYPE OUT MUS5 NUMBERS
603 JPRNT=-JPRNT
IF(IDEV.EQ.1)GO TO 402
C IDEV=1 = GO BACK TO 'INPUT'
GO TO 502
CCC604 JWRT=-JWRT
C!*** DEFAULT IS NO-WRITE BINARY
CCC GO TO 401
602 IF(I(1).NE.IALT)GO TO 408
CCC IF(I(2).NE.'I')GO TO 605
C!***<ALT>I(NSTRUMENT LIST;)
DO 606 K=1,INUM
JK=NPAR(K)-2
606 TYPE 607,(INST(K,L),L=1,5),INSNUM(K),JK
GO TO 5
607 FORMAT(1X,5A1,' NUM=',I2,' PARAMS=',I2)
C!*** PRINTS INST INFO.
CCC605 SBFILN=FILNM
CCCCC CALL PLAY
C!**** GO PLAY SOMETHING
CCC GO TO 5
408 DO 407 K=1,60
407 JX(K)=IBLA
DO 405 K=1,80
IF(I(K).EQ.LESS)GO TO 5
405 IF(I(K).NE.IBLA)GO TO 406
GO TO 5
406 MM=0
J=-1
IPRNT=0
JI=0
9 M=0
N=JI+1
6 JI=JI+1
K=I(JI)
DO 7 L=1,12
7 IF(K.EQ.LX(L))GO TO 8
M=M+1
GO TO 6
C!**** NO STRING CAN EXCEED 10 CHARS.
8 IF(K.EQ.LESS)GO TO 15
IF(M.EQ.0)GO TO 140
IF(M.GT.10)M=10
MM=MM+1
IF(MM.LE.50)GO TO 88
TYPE 888,(I(JJ),JJ=N,N+9)
STOP
888 FORMAT(' LINE TOO LONG -- ',10A1)
88 JJ=I(N)
IF(JJ)GO TO 16
C!***** JUMP IF 1ST CHAR. IS A LETTER.
Y=0
DOT=10.
DO 18 JK=N,N+M-1
JA=I(JK)
IF(JA.NE.IDOT)GO TO 17
DOT=.1
GO TO 18
17 X=NASCI(JA)
C!**** CHANGE ASCII INTO NUMBER
IF(DOT.LT.1)GO TO 19
Y=Y*DOT+X
GO TO 18
19 Y=Y+X*DOT
DOT=DOT/10.
18 CONTINUE
RX(MM*2-1)=Y
RX(MM*2)=-9999.0
GO TO 140
16161 FORMAT(1X,I,3X10A1)
16 RX(MM*2-1)=0
CALL MPACK(M,I(N),IX(MM),N)
C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
26262 IF(JPRNT)TYPE 16161,IX(MM),(I(KHH),KHH=N,N+M-1)
IJ=JX(MM*2-1)
IF(IJ.GE.0)GO TO 244
JX(MM*2)=M
C SAVE THE WD CNT OF POTENTIAL INST. NAME.
GO TO 10
244 IF(IJ.NE.412)GO TO 140
CCC IF(IXJ.NE.'INSTR')GO TO 14
INS=0
GO TO 5
144 MX=MX+1
MX5(MX)=IXJ
C!*** PUT IS NEW UNIT GEN. NAME
MX=MX+1
MX5(MX)=RX(3)
GO TO 5
140 IF(IJ.NE.413)GO TO 143
CCC140 IF(IXJ.NE.'UNIT')GO TO 143
INS=1
C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
GO TO 5
143 IF(K.EQ.IBL)GO TO 10
IF(L.EQ.8)K=IAROW
C!::: CHANGE = INTO ←
MM=MM+1
JX(MM*2-1)= K
10 IF(I(JI+1).NE.IBL)GO TO 11
JI=JI+1
GO TO 10
11 IF(JI.LT.80)GO TO 9
C NOW WE HAVE ALL ITEMS IN IX ARRAY
15 MM=MM*2
IF(IJ.NE.404)GO TO 142
CCC IF(IXJ.NE.KPRNT)GO TO 142
INS=-1
C!***** FOR 'PRINT'
IPRNT=-1
142 J=-1
IF(INS.LT.0)GO TO 305
IF(INS.EQ.2)GO TO 305
26 IF(IJ.NE.12)GO TO 127
CCC26 IF(IXJ.NE.'END')GO TO 127
MM=0
INS=-1
C!***** NOW INITITIALIZATION COMPLETE
GO TO 5
127 IF(INS.EQ.1)GO TO 144
C!*** FOR 'UNIT GEN' ADDED
CXCX ASSUMES INST NAME STARTS IN COL.1 L=N-1
L=0
M=JX(2)
IF(INUM.EQ.0)GO TO 2127
DO 1127 KL=1,INUM
C!** FOR POSSIBLE REDEFINITION OF INST.
CC1127 IF(IXJ.EQ.INST(KL))GO TO 3127
DO 21 LQ=1,M
21 IF(INST(KL,LQ).NE.I(L+LQ))GO TO 1127
C TRY TO MATCH UP LETTERS WITH EXISTING INST. NAMES.
GO TO 3127
C!*** IS INST ALREADY IN LIST?
C JUMP OUT IF MATCH WAS FOUND
1127 CONTINUE
2127 INUM=INUM+1
K=INUM
CC3127 INST(K)=IXJ
DO 20 LQ=1,M
20 INST(K,LQ)=I(L+LQ)
C!**** GET THE NAME OF AN INST.(5 LTRS ONLY)
3127 INSNUM(K)=RX2
C!*** GET ITS NUMBER.
NPAR(K)=RX3+2
C!**** GET NUM OF PARAMS, ADD 3 FOR W ARRAY
K=7
28 LL=-1
IF(JX(K).NE.410)GO TO 31
CCC IF(JX(K).NE.IDUR)GO TO 31
C IF IT'S NOT 'DUR' THEN IT MUST BE 'FREQ'
LL=-LL
C!*** NOW LOOK AT REST OF THE LINE
31 K=K+2
IF(K.GT.MM)GO TO 5
C!**** CHECK FOR END OF LINE
IF(RX(K+1).NE.-9999.0)GO TO 28
JA=RX(K)+2
IF(JA.LT.5)GO TO 31
C!***** IGNORE P1,P2 OF INPUT
FQDR(JA,INUM)=LL
C!**** 1=DUR, -1=FREQ, 0=ORDINARY NUM.
GO TO 31
50 IF(IGEN)308,309,309
309 LL=LL-1
IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
C!*** FOUND 'END'
GO TO 59
308 W(1)=1
IF(LL-1.GE.NPAR(IK))GO TO 56
54 IF(LL.LT.3)LL=3
DO 55 K=LL,NPAR(IK)-1
55 W(K)=P(K-2)
C!***** GET INFO ALREADY IN PARAMS
56 DO 57 K=3,LL-1
57 P(K-2)=W(K)
C!**** FILL UP P LIST AGAIN
X=W(3)
C!*** EXCHANGE W(2) AND W(3), ACTION TIME, INST #
W(3)=W(2)
W(2)=X
58 LL=NPAR(IK)
DO 52 K=5,LL-1
X=FQDR(K,IK)
IF(X.EQ.0)GO TO 52
IF(X)GO TO 53
W(K)=RMAG/W(K)
GO TO 52
53 W(K)=RMAG*W(K)
52 CONTINUE
IF(ENDX.LT.W(2)+P2)ENDX=W(2)+P2
W(LL)=RMAG/W(4)
C!********* PUT MAG/P2 AT END
59 IF(JPRNT.GE.0)GO TO 591
TYPE 590,KNAM
KNAM=IBLA
TYPE 51,LL,(W(K),K=1,LL)
CXX WRITE(22,51)LL,(W(K),K=1,LL)
C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
591 IF(JWRT.GE.0)GO TO 500
IF(IOPEN)CALL OFILE(21,JFLNM)
C OPENS FILE, IF NOT ALREADY OPEN.
WRITE(21)LL,(W(K),K=1,LL)
IOPEN=0
500 IFIRST=0
IF(IGEN.EQ.0)IGEN=-1
GO TO 555
CC RETURN
590 FORMAT(I6)
CCC590 FORMAT(1XA5,1X$)
306 IF(JPRNT)TYPE 1307,(W(K),K=1,LL-1)
IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
IPRNT=0
C!** RESET NO-PRNT FLAG
JSEM=0
C!** RESET SEMICOLON FLAG
INS=-1
IF(J.GE.MM-1)GO TO 5
C!** GO READ ANOTHER LINE
305 CALL MSCAN(LL,W)
303 IF(IPRNT)GO TO 306
IF(J.LT.MM)JSEM=-1
C!**** STILL MORE CHARS TO COME.
IF(ENDX.GE.0)GO TO 302
ENDX=0
GO TO 500
302 IF(JSEM)50,5,5
51 FORMAT(I3,35F10.3)
307 FORMAT('+',F8.2,$)
1307 FORMAT(F10.3)
END
FUNCTION NASCI(N)
DATA IEX/536870912/,IZERO/'0'/
C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
NASCI=(N-IZERO)/IEX
C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
END